home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpbind.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  4.3 KB  |  131 lines
  1. ;;; CMPBIND  Variable Binding.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'bds-bind 'set-bds-bind 'set-loc)
  25.  
  26. ;;; Those functions that call the following binding functions should
  27. ;;; rebind the special variables,
  28. ;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*.
  29.  
  30. (defun c2bind (var)
  31.   (case (var-kind var)
  32.         (LEXICAL
  33.          (when (var-ref-ccb var)
  34.                (wt-nl)
  35.                (wt-vs (var-ref var))
  36.                (wt "=MMcons(") (wt-vs (var-ref var))
  37.                (wt ",") (wt-clink) (wt ");")
  38.                (clink (var-ref var))
  39.                (setf (var-ref-ccb var) (ccb-vs-push))))
  40.         (SPECIAL
  41.          (wt-nl "bds_bind(VV[" (var-loc var) "],") (wt-vs (var-ref var))
  42.          (wt ");")
  43.          (push 'bds-bind *unwind-exit*))
  44.     (DOWN
  45.       (cond ((integerp (var-loc var))
  46.          (wt-nl "base0[" (var-loc var) "]=")
  47.          (wt-vs (var-ref var))
  48.          (wt ";"))
  49.         (t (wfs-error))))
  50.     (INTEGER
  51.      (wt-nl "SETQ_IO(V" (var-loc var)","
  52.         "V" (var-loc var)"alloc,")
  53.      (wt "(") (wt-vs (var-ref var)) (wt "));"))
  54.         (t
  55.          (wt-nl "V" (var-loc var) "=")
  56.          (case (var-kind var)
  57.                (OBJECT)
  58.                (FIXNUM (wt "fix"))
  59.                (CHARACTER (wt "char_code"))
  60.                (LONG-FLOAT (wt "lf"))
  61.                (SHORT-FLOAT (wt "sf"))
  62.                (t (baboon)))
  63.          (wt "(") (wt-vs (var-ref var)) (wt ");")))
  64.   )
  65.  
  66. (defun c2bind-loc (var loc)
  67.   (case (var-kind var)
  68.         (LEXICAL
  69.          (cond ((var-ref-ccb var)
  70.                 (wt-nl)
  71.                 (wt-vs (var-ref var))
  72.                 (wt "=MMcons(" loc ",") (wt-clink) (wt ");")
  73.                 (clink (var-ref var))
  74.                 (setf (var-ref-ccb var) (ccb-vs-push)))
  75.                (t
  76.                 (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";"))))
  77.         (SPECIAL
  78.          (wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");")
  79.          (push 'bds-bind *unwind-exit*))
  80.  
  81.         (DOWN
  82.       (wt-nl "base0[" (var-loc var) "]=" loc ";"))
  83.     (INTEGER
  84.      (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))
  85.        (save-avma '(nil integer))
  86.        (wt-nl "V" (var-loc var) "= ")
  87.        (wt-integer-loc loc var)
  88.        (wt ";")
  89.        (close-inline-blocks)))
  90.         (t
  91.          (wt-nl "V" (var-loc var) "= ")
  92.          (case (var-kind var)
  93.                (OBJECT (wt-loc loc))
  94.                (FIXNUM (wt-fixnum-loc loc))
  95.                (CHARACTER (wt-character-loc loc))
  96.                (LONG-FLOAT (wt-long-float-loc loc))
  97.                (SHORT-FLOAT (wt-short-float-loc loc))
  98.                (t (baboon)))
  99.          (wt ";")))
  100.   )
  101.  
  102. (defun c2bind-init (var init)
  103.   (case (var-kind var)
  104.         (LEXICAL
  105.          (cond ((var-ref-ccb var)
  106.                 (let ((loc (list 'vs (var-ref var))))
  107.                      (let ((*value-to-go* loc))
  108.                           (c2expr* init))
  109.                      (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*)
  110.                      (wt ");"))
  111.                 (clink (var-ref var))
  112.                 (setf (var-ref-ccb var) (ccb-vs-push)))
  113.                (t
  114.                 (let ((*value-to-go* (list 'vs (var-ref var))))
  115.                      (c2expr* init)))))
  116.         (SPECIAL
  117.          (let ((*value-to-go* (list 'bds-bind (var-loc var))))
  118.               (c2expr* init))
  119.          (push 'bds-bind *unwind-exit*))
  120.     (DOWN
  121.       (let ((*value-to-go* (list 'down (var-loc var))))
  122.         (c2expr* init)))
  123.         ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)
  124.          (let ((*value-to-go* (list 'var var nil)))
  125.               (c2expr* init)))
  126.         (t (baboon)))
  127.   )
  128.  
  129. (defun set-bds-bind (loc vv)
  130.        (wt-nl "bds_bind(VV[" vv "]," loc ");"))
  131.